home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Format CD 49
/
Amiga Format CD49 (2000-01-17)(Future Publishing)(GB)(Track 1 of 3)[!][issue 2000-02].iso
/
-serious-
/
programming
/
basic
/
imagedtinfo
/
imagedtinfo.bas
< prev
next >
Wrap
BASIC Source File
|
1999-12-06
|
6KB
|
175 lines
REM =========================================================================
REM ImageDTInfo [<image_filename>/<nombre_fichero_imagen>|?]
REM
REM Created for use with FWCalendar Arexx script written by Ron Goertz
REM and as a little coding exercise with (Hisoft|Maxon) Basic 2.
REM You can re-use freely this code in your own works.
REM
REM Creado para usar con el guión ARexx FWCalendar de Ron Goertz
REM y como un pequeño ejercicio de programación con (Hisoft|Maxon) Basic 2.
REM Puede reutilizar libremente es código en sus producciones.
REM AmiSpaTra - http://www.arrakis.es/~amidde/
REM =========================================================================
REM $NOWINDOW
' ******** Constants, structs (sizes and offsets) and "prototypes" **********
' *** Constantes, estructuras (tamaños y desplazamientos) y "prototipos" ****
REM $include utility.bc
REM $include intuition.bc
REM $include datatypes/datatypesclass.bc
REM $include datatypes/pictureclass.bc
REM $include dos.bh
REM $include datatypes.bh
' *************** Opening libraries / Apertura de bibliotecas **************
' IoErr()
' -------
LIBRARY OPEN "dos.library"
' NewDTObjectA(), GetDTAttribsA(), DisposeDTObject()
' --------------------------------------------------
LIBRARY OPEN "datatypes.library"
' ******** Variables initialization / Inicialización de variables ***********
' Copyright string / Cadena de autoría
' ------------------------------------
version$ ="$VER: ImageDTInfo 1.1 (29.11.99) by © Dámaso D. Estévez <amidde@arrakis.es>"
' Pointer to structs / Puntero a estructura: `Object'
' ---------------------------------------------------
o& = NULL&
' Pointer to structs / Puntero a estructura: `BitMapHeader'
' ---------------------------------------------------------
b& = NULL&
' Pointers to structs / Puntero a estructura: `DataType'
' ------------------------------------------------------
d& = NULL&
' Array for taglist's work.
' Matriz para trabajar con listas de atributos-propiedades.
' ---------------------------------------------------------
DIM tags&(4)
' For contain the IO error / Para memorizar el código de error E/S
' ----------------------------------------------------------------
retval& = NULL&
' ************************ Main code / Código principal *********************
IF COMMAND$ <> "" AND COMMAND$ <> "?" THEN
' Tags array for `NewDTObjectA()' (only image picture files).
' Lista de atributos para `NewDTObjectA()' (sólo ficheros gráficos).
' -----------------------------------------------------------------
TAGLIST VARPTR(tags&(0)),_
DTA_SourceType&,DTST_FILE&,_
DTA_GroupID&,GID_PICTURE&,_
TAG_DONE&
' To set pointers to empty structures (`Datatype' & `BitMapHeader').
' Definir punteros a estructuras vacias (`Datatype' & `BitMapHeader').
' --------------------------------------------------------------------
d&=SADD(STRING$(Datatype_sizeof%,CHR$(0)))
b&=SADD(STRING$(BitMapHeader_sizeof%,CHR$(0)))
' If I obtain theses "structs"... / Si consigo crear esas "estructuras"...
' ------------------------------------------------------------------------
IF d& <> NULL& AND b& <> NULL& THEN
' ... I ask my object (the graphic file) for work with this.
' ... solicito mi objeto (el fichero gráfico) para trabajar con él.
' -----------------------------------------------------------------
o& = NewDTObjectA&(SADD(COMMAND$+CHR$(0)),VARPTR(tags&(0)))
' If the answer is positive... / Si la respuesta es positiva...
' -------------------------------------------------------------
IF o& <> NULL& THEN
' I need the height, widht, planes and image type info.
' Necesito la altura, anchura, planos y tipo de imagen.
' -----------------------------------------------------
TAGLIST VARPTR(tags&(0)),_
PDTA_BitMapHeader&,VARPTR(b&),_
DTA_Datatype&, VARPTR(d&),_
TAG_DONE&
' I ask the info needed and if this works (the answer is the the attrib asked number)...
' Solicito la información que necesito y si se nos devuelve el nº de atributos pedidos...
' ---------------------------------------------------------------------------------------
IF (GetDTAttrsA&(o&,VARPTR(tags&(0)))) = 2 THEN
' ... prints the info / ... imprimo la información
' The subclass type has four chars / El tipo de subclase ocupa cuatro caracteres
' ------------------------------------------------------------------------------
PRINT UCASE$(CHR$(PEEK(PEEKL(d&+dtn_Header%)+dth_ID%+0%)));
PRINT UCASE$(CHR$(PEEK(PEEKL(d&+dtn_Header%)+dth_ID%+1%)));
PRINT UCASE$(CHR$(PEEK(PEEKL(d&+dtn_Header%)+dth_ID%+2%)));
PRINT UCASE$(CHR$(PEEK(PEEKL(d&+dtn_Header%)+dth_ID%+3%)));
PRINT " -";
PRINT PEEKW(b&+bmh_Width%);
PRINT "x";
PRINT PEEKW(b&+bmh_Height%);
PRINT "x";
PRINT PEEK(b&+bmh_Depth%)
ELSE
' Assign the IoErr&() result inmediatly or you will lost this.
' Asigne el resultado de IoErr&() inmediatamente a una variable o lo perderá.
' ---------------------------------------------------------------------------
retval& = IoErr&()
END IF
' I've finnished with the object... I release this.
' Hemos terminado con el objeto... así que lo liberamos.
' ------------------------------------------------------
DisposeDTObject&(o&)
ELSE
retval& = IoErr&()
END IF
ELSE
PRINT "* ERROR * - BitMapHeader/DataType"
PRINT "No memory for structs - Memoria insuficiente para las estructuras"
END IF
ELSE
' The user asks info or don't include a filename as argument.
' El usuario pide información o no incluye un nombre de fichero como argumento.
' -----------------------------------------------------------------------------
PRINT
PRINT RIGHT$(version$,LEN(version$)-6)
PRINT
PRINT "This program needs as argument ONLY a graphic filename."
PRINT "Este programa necesita como argumento SÓLO el nombre de un fichero gráfico."
PRINT
END IF
' If there was some I/O related error, prints the error code and the CLI parameter.
' Si se ha producido algún error E/S, imprime el código de error y el argumento CLI.
' ----------------------------------------------------------------------------------
IF retval& <> 0 THEN
PRINT "* ERROR * - IoErr&()"
PRINT "Code/código: ";retval&;" - Argument/argumento: `";COMMAND$;"'"
END IF
END